COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	fexpr compl file ← begin scalar z
C00008 00003	complis[z,m,k,vpr] ←
C00011 ENDMK
C⊗;
fexpr compl file ← begin scalar z;
	eval[ OUTPUT . [ DSK: . list[a file . LAP]]]
	eval[ INPUT . [DSK: . file]]
	inc[T,NIL]
	outc[T,NIL]
  loop: z ← errset read[]
	if at z then goto done
	z ← a z
	if a z eq DE then
	begin scalar prog;
		prog ← comp[ad z,add z,addd z]
		mapc[print,prog]
		outc[NIL,NIL]
		print (ad z,length prog)
		outc[T,NIL]
	end
	else print z
	go to loop
  done: outc[NIL,T]
	inc[NIL,T]
	return ENDCOMP
	end



comp[fn,vars,exp] ← {prup[vars,1],length vars}[λvpr,n.
	((LAP,fn,SUBR)) * mkpush(n,1) * compexp[exp,-n,vpr]
	* substack n * ((POPJ P)) NIL)))

substack n ← if n=0 then NIL else (( SUB,P,( C,0,0,n,n ))

prup[vars,n] ← if n vars then NIL else [a vars . n] . prup[d vars,n+1]

mkpush[n,m] ← if n<m then NIL else (PUSH,P,m) . mkpush[n,m+1]

compexp[exp,m,vpr] ←
	if n exp then (( MOVEI 1 0 ))
	else if exp eq T or numberp exp then (( MOVEI,1,( QUOTE,exp )))
	else if at exp then (( MOVE,1,m+d assoc[exp,vpr],P ))
	else if a exp eq CAR then
		if at ad exp then (( HLRZ@,1,m+d assoc[ad exp,vpr], P ))
		else compexp[ad exp,m,vpr] * (( HLRZ@ 1 1 ))
	else if a exp eq CDR then
		if at ad exp then (( HRRZ@,1,m+d assoc[ad exp,vpr], P ))
		else compexp[ad exp,m,vpr] * (( HRRZ@ 1 1 ))
	else if [a exp eq AND] ∨ [a exp eq OR] ∨ [a exp eq NOT]
		∨ [a exp eq EQ] then {gensym[],gensym[]}[λl1,l2.
			combool[exp,m,l1,NIL,vpr]
			* (( MOVEI 1 ( QUOTE T )),(JRST,0,l2),l1,
				(MOVEI 1 0),l2) ]
	else if a exp eq COND then comcond[d exp,m,gensym1[],vpr]
	else if a exp eq QUOTE then (( MOVEI,1,exp ))
	else if at a exp then complisa[d exp,m,vpr]
		* (( CALL,length d exp,(E,a exp) ))
	else if aa exp eq LAMBDA then {length d exp}[λn.
		stackup[d exp,m,vpr]
		* compexp[adda exp,m-n,prup[ada exp,1-m]*vpr]
		* substack n ]

stackup[u,m,vpr] ← if n u then NIL
	else compexp[a u,m,vpr] * ((PUSH P 1)) * stackup[d u,m-1,vpr]

ccchain exp ← [a exp eq CAR  ∨  a exp eq CDR] 
			∧ [at ad exp  ∨  ccchain ad exp]

compc[exp,n2,m,vpr] ←
	if at exp then error COMPC
	else if a exp eq CAR then
		if at ad exp then (( HLRZ@,n2,m+d assoc[ad exp,vpr] ))
		else (HLRZ@,n2,n2) . compc[ad exp,n2,m,vpr]
	else if at ad exp then ((HRRZ@,n2,m+d assoc[ad exp,vpr] ))
	else (HRRZ@,n2,n2) . compc[ad exp,n2,m,vpr]

comcond[u,m,l,vpr] ←
	if n u then (l)
	else if [¬at aa u] ∧ [aaa u eq NULL] ∧ [n ada u]
		then compexp[adaa u,m,vpr] * ((JUMPE,1,l))
			* comcond[d u,m,l,vpr]
	else if aa u eq T then compexp[ada u,m,vpr] * (l)
	else {gensym1[]}[λl1.
		combool[aa u,m,l1,NIL,vpr]
		* compexp[ada u,m,vpr]
		* ((JRST,0,l),l1)
		* comcond[d u,m,l,vpr]  ]

complisa[u,m,vpr] ← {classify u}[λz.
	complis[z,m,1,vpr]
	* loadac[z,1-ccount z,1,m-ccount z,vpr]
	* substack[ccount z]  ]

ccount z ← if n z then 0 else if aa z = 4 then 1+ccount d z else ccount d z

loadac[z,m2,n2,m,vpr] ←
	if n z then NIL
	else if aa z = 1 then
		(MOVE,n2,m+d assoc[da z,vpr],P) . loadac[d z,m2,n2+1,m,vpr]
	else if aa z = 0 then
		(MOVEI,n2,(QUOTE,da z)) . loadac[d z,m2,n2+1,m,vpr]
	else if aa z = 2 then
		(MOVEI,n2,da z) . loadac[d z,m2,n2+1,m,vpr]
	else if aa z = 3 then
		[reverse compc[da z,n2,m,vpr]] * loadac[d z,m2,n2+1,m,vpr]
	else if aa z = 5 then loadac[d z,1,n2+1,m,vpr]
	else (MOVE,n2,m2,P) . loadac[d z,m2+1,n2+1,m,vpr]
complis[z,m,k,vpr] ←
	if n z then NIL
	else if aa z = 4 then compexp[da z,m,vpr] * ((PUSH P 1))
		* complis[d z,m-1,k+1,vpr]
	else if aa z = 5 then compexp[da z,m,vpr]
		* [if k=1 then NIL else ((MOVE,k,1)) ]
	else complis[d z,m,k+1,vpr]

classify u ← class2[class1[u,NIL],NIL,T]

class1[u,v] ←
	if n u then v
	else if at a u then
		if [a u eq NIL] ∨ [a u eq T] ∨ [numberp a u] then
			class1[du,[0 . a u] . v]
		else class1[d u,[1 . a u] . v]
	else if aa u eq QUOTE then class1[d u,[2 . a u] . v]
	else if ccchain a u then class1[d u,[3 . a u] . v]
	else class1[du,[4 . a u] . v]

class2[u,v,flg] ←
	if n u then v
	else if flg ∧ [aa u = 4] then class2[d u,[5 . da u] . v, NIL]
	else class2[d u, a u . v, flg]

mkjrst l ← ((JRST,0,l))

combool[p,m,l,flg,vpr] ←
	if p eq T then [if flg then mkjrst l else NIL]
	else if at p then compexp[p,m,vpr]
		* ((if flg then JUMPN else JUMPE,1,l))
	else if a p eq EQ then complisa[d p,m,vpr]
		* [if flg then ((CAMN 1 2)) else ((CAME 1 2))]
		* mkjrst l
	else if a p eq AND then
		if flg then compandor[d p,m,l,NIL,vpr]
		else {gensym1[]}[λl1.compandor1[d p,m,l1,l,NIL,vpr] * (l1)]
	else if a p eq OR then
		if flg then compandor[d p,m,l,T,vpr]
		else {gensym1[]}[λl1.compandor1[d p,m,l1,l,T,vpr] * (l1)]
	else if a p eq NOT then combool[ad p,m,l,¬flg,vpr]
	else if a p eq NULL then compexp[ad p,m,vpr]
		* ((if flg then JUMPE else JUMPN,1,l))
	else compexp[p,m,vpr] * ((if flg then JUMPN else JUMPE,1,l))

compandor[u,m,l,flg,vpr] ← if n u then NIL
	else combool[a u,m,l,flg,vpr] * compandor[d u,m,l,flg,vpr]

compandor1[u,m,l,l2,flg,vpr] ← if n u then mkjrst l2
	else if n d u then combool[a u,m,l2,¬flg,vpr]
	else combool[a u,m,l,flg,vpr] * compandor1[d u,m,l,l2,flg,vpr]

gensym1[] ← (LABEL gensym[])